home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / v3 / modlib_s.lha / modlib_src / $assert.P < prev    next >
Text File  |  1990-04-12  |  11KB  |  290 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24. /* $assert.P */
  25.  
  26. $assert_export([$assert/1,$asserta/1,$asserta/2,$assertz/1,$assertz/2,
  27.         $assert/2,$asserti/2,$assert/4,$assert_union/2,$assert_call_s/1,
  28.         $assert_get_prref/2,$assert_put_prref/2,$assert_abolish_i/1]).
  29.  
  30. /* $assert_use($meta,[$functor/3,$univ/2,$length/2]).
  31.    $assert_use($blist,[$append/3,$member/2,$memberchk/2]).
  32.    $assert_use($buff, [$alloc_perm/2,$alloc_heap/2,$trimbuff/3,
  33.                        $buff_code/4,$symtype/2,$substring/6,$subnumber/6,
  34.                        $subdelim/6,$conlength/2,$pred_undefined/1,$hashval/3]).
  35.    $assert_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,
  36.                  $tell/1,$tell/2,$telling/1,$told/0,$get/1,$get0/1,
  37.                      $see/1,$seeing/1,$seen/0]).
  38.    $assert_use($db,[$db_new_prref/1,$db_assert_fact/5,
  39.                     $db_assert_fact/7, $db_add_clref/6,
  40.             $db_call_prref/2,$db_call_prref_s/2,$db_call_prref_s/3,
  41.             $db_call_clref/2,$db_get_clauses/3,$db_kill_clause/1]).
  42. */
  43.  
  44. $assert_exp_cut((Head:-Body),(Nhead:-Nbody)) :- !,
  45.     $univ(Head,Hlist),$append(Hlist,[Cutpoint],Nhlist),
  46.     $univ(Nhead,Nhlist),
  47.     $assert_exp_cutb(Body,Nbody,Cutpoint).
  48.  
  49. $assert_exp_cut(Head,Head) .  /* leave unchanged, Arity is one less */
  50.  
  51. $assert_exp_cutb(X,call(X),_) :- var(X),!.
  52. $assert_exp_cutb(!,'_$cutto'(Cutpoint),Cutpoint) :- !.
  53. $assert_exp_cutb((X,Y), (call(X), call(Y)), _) :-
  54.     var(X), var(Y), !.
  55. $assert_exp_cutb((X,Y,Z), (call(X), call(Y), call(Z)), _) :-
  56.     var(X), var(Y), var(Z), !.
  57. $assert_exp_cutb((A,B,C,D),','(Na,Nb,Nc,Nd),Cutpoint) :- !, /* opt */
  58.     $assert_exp_cutb(A,Na,Cutpoint),
  59.     $assert_exp_cutb(B,Nb,Cutpoint),
  60.     $assert_exp_cutb(C,Nc,Cutpoint),
  61.     $assert_exp_cutb(D,Nd,Cutpoint).
  62. $assert_exp_cutb((A,B),(Na,Nb),Cutpoint) :- !,
  63.     $assert_exp_cutb(A,Na,Cutpoint),
  64.     $assert_exp_cutb(B,Nb,Cutpoint).
  65. $assert_exp_cutb((A;B),(Na;Nb),Cutpoint) :- !,
  66.     $assert_exp_cutb(A,Na,Cutpoint),
  67.     $assert_exp_cutb(B,Nb,Cutpoint).
  68. $assert_exp_cutb((A->B),(A->Nb),Cutpoint) :- !,
  69.     $assert_exp_cutb(B,Nb,Cutpoint).
  70. $assert_exp_cutb(X,X,_).
  71.  
  72. $assert(Clause) :-
  73.      $assert_get_index(Clause,Index),
  74.      $assert(Clause,1,Index,_).
  75.  
  76. $asserta(Clause) :- $assert(Clause,0,0,_).
  77. $asserta(Clause,Ref) :- $assert(Clause,0,0,Ref).
  78.  
  79. $assertz(Clause) :- 
  80.           $assert_get_index(Clause,Index),
  81.       $assert(Clause,1,Index,_).
  82.  
  83. $assertz(Clause,Ref) :-
  84.      $assert_get_index(Clause,Index),
  85.      $assert(Clause,1,Index,Ref).
  86.  
  87. $assert(Clause,Clref) :-
  88.      $assert_get_index(Clause,Index),
  89.      $assert(Clause,1,Index,Clref).
  90.  
  91. $asserti(Clause,Index) :- $assert(Clause,1,Index,_).
  92.  
  93. $assert(Clause, AZ, Index, Clref) :- 
  94.     $assert_exp_cut(Clause,Nclause),  
  95.     $assert_cvt_dyn(Clause,Prref,Where,Supbuff),
  96.     $db_assert_fact(Nclause,Prref,AZ,Index,Clref,Where,Supbuff).
  97.  
  98.  
  99. $assert_get_index(Clause,Index) :-
  100.      (Clause \= (_ :- _) ->
  101.           ($functor0(Clause,P), $arity(Clause,N)) ;
  102.       (arg(1,Clause,Hd), $functor0(Hd,P), $arity(Hd,N))
  103.      ),
  104.      (($symtype('_$index'(_,_,_),IType),
  105.        IType > 0,
  106.        '_$index'(P,N,Index)
  107.       ) ->
  108.            true ;
  109.        Index = 1
  110.      ).
  111.      
  112.  
  113. /* this is a translator for facts. It takes a term that represents 
  114.    a predicate call (a fact) and generates and writes the code 
  115.    corresponding to the fact into a buffer. It then asserts the fact 
  116.    by adding it to the end of the tryme-retryme-trustme sequence for
  117.    the main predicate of the fact.
  118. */
  119.  
  120.  
  121. /* $assert(Fact,AZ,Index,Clref):  asserts a fact to a fact-defined 
  122. predicate. Fact is the fact to assert. AZ is 0 for insertion as the
  123. first clause; 1 for insertion as the last clause. Index is the number of 
  124. the argument on which to index; 0 for no indexing. Clref is returned as
  125. the clause reference of the fact newly asserted. */
  126.  
  127.  
  128. $assert_cvt_dyn(Clause,Prref,Where,Supbuff) :-
  129.     (Clause = (Fact:-B),! ; Clause=Fact),
  130.     $symtype(Fact, SYMTYPE),
  131.     (SYMTYPE =:= 1 ->        /* already dynamic */
  132.       $assert_get_prref(Fact,Prref,Where,Supbuff)
  133.       ;
  134.       Where = 0,
  135.       (SYMTYPE =:= 0 ->        /* undefined, this is first clause */
  136.         $db_new_prref(Prref),
  137.         $assert_put_prref(Fact,Prref)
  138.         ;
  139.         (SYMTYPE =:= 2 ->        /* compiled, so convert */
  140.           $assert_cvt_buff(Fact,Ccls),
  141.           $db_new_prref(Prref),
  142.           $assert_put_prref(Fact,Prref),
  143.           $arity(Fact,Arity1),Arity is Arity1+1,
  144.           $db_add_clref(Fact,Arity,Prref,1,0,Ccls)
  145.           ;
  146.           $writename('Error, cannot assert into Buffer'),$nl,fail
  147.         )
  148.       )
  149.     ).
  150.  
  151.  
  152. /* return a buffer with a branch to the clauses for Fact */
  153. $assert_cvt_buff(Fact,Tbuff) :-
  154.         $opcode( jump, JmpOp ),
  155.     $alloc_perm( 20,Tbuff),   /* buff to convert to dynamic */
  156.     $buff_code(Tbuff,  0, 14 /*ptv */ , Tbuff),    /* back ptr */
  157.     $buff_code(Tbuff, 12,  3 /*ps  */ , JmpOp /*jump*/ ),
  158.     $buff_code(Tbuff, 14,  3 /*ps  */ , 0),
  159.     $buff_code(Tbuff, 16, 20 /*pepb*/ , Fact).
  160.  
  161.  
  162. /* assert_union adds the clauses of the second predicate
  163.    to the first predicate. E.g., given p(X,Y) and q(X,Y), it adds the rule
  164.    p(X,Y) :- q(X,Y) as the last rule defining p. If p is not defined, then
  165.    it results in the call of q being the only clause for p */
  166.  
  167. $assert_union(P,Q) :- 
  168.     $assert_cvt_buff(Q,Qclref),
  169.     $assert_cvt_dyn(P,Prref,0,0),
  170.     $arity(P,Arity1),Arity is Arity1+1,
  171.     $db_add_clref(P,Arity,Prref,1,0,Qclref).
  172.     
  173. /* This defines routines that can be used to assert facts onto the heap.
  174. */
  175.  
  176. /* We have introduced a new simulator instruction similar  to the one
  177. used to translate variables in globalset.  It is a branch
  178. instruction, called executev.  It  derefs its  argument and  if it is
  179. not a variable, does an execute to main functor symbol.  (Execute has
  180. been modified so that when a buffer is called, it branches  to disp 4
  181. in the name.)  If it  is a  variable, it  gives an  error message and
  182. fails.  */ 
  183.  
  184. /* $assert_new_t_prref(Call,Prref,Supbuff):  Call must be
  185. instantiated to a term (just used for getting psc).  If  that psc has
  186. no e.p.  then this creates a permanent buffer  containing an executev
  187. instruction, and the constant  for the  Supbuff, and  points the e.p.
  188. of Call to it.  A Prref is allocated and  the target  of the executev
  189. is set to that.  If the psc already has an e.p., the predicate fails.
  190. */ 
  191.  
  192. $assert_new_t_prref(Call,Prref,Supbuff) :-
  193.     $opcode( noop, NoopOp ),
  194.     $opcode( executev, ExecOp ),
  195.     $symtype(Call,Type),
  196.     (Type =:= 1,    /* dynamic */
  197.      $buff_code(Call,   0,  7 /*gepb*/ ,Vbuff),
  198.      $buff_code(Vbuff,  4,  6 /*gs  */ , NoopOp /*noop*/ ),
  199.      $buff_code(Vbuff,  6,  6, 0),
  200.      $buff_code(Vbuff,  8,  6, ExecOp  /* executev */ ),
  201.      $buff_code(Vbuff, 12, 18 /*ubv */ ,Prref),
  202.      $db_new_prref(Prref,2,Supbuff),
  203.      $buff_code(Vbuff, 16, 18 /*ubv */ ,Supbuff),
  204.      !
  205.     ;
  206.      $buff_code(Call,0,11,0), /* this overrides everything!! */
  207.      /* allocate new executev instruction, and supbuff ptr */
  208.      $alloc_perm(20,Vbuff), /* must make permanent */
  209.      $buff_code(Vbuff,  0, 14, Vbuff), /* set back ptr */
  210.      $buff_code(Call,   0,  9 /*pep*/ ,Vbuff),
  211.      $buff_code(Vbuff,  4,  3 /*ps */ , NoopOp /*noop*/ ),
  212.      $buff_code(Vbuff,  6,  3, 0),
  213.      $buff_code(Vbuff,  8,  3, ExecOp  /* executev */ ),
  214.      $buff_code(Vbuff, 10,  3, 0),
  215.      $buff_code(Vbuff, 12, 12 /*fv */ ,0),
  216.      $buff_code(Vbuff, 16, 12 /*fv */ ,0),
  217.      $db_new_prref(Prref,2,Supbuff),
  218.      $buff_code(Vbuff, 12, 18 /*ubv*/ ,Prref),
  219.      $buff_code(Vbuff, 16, 18 /*ubv*/ ,Supbuff)
  220.     ).
  221.  
  222.  
  223. /* $assert_alloc_t must be called first to declare that a predicate (or set
  224. of predicates) are to have facts asserted into them on the  heap.  It
  225. is given a list of Pred/Arity pairs and a size.  That  amount of heap
  226. space is reserved for facts to  be asserted  to these  predicates.  A
  227. temporary prref buffer is created.  */ 
  228.  
  229. $assert_alloc_t(Palist,Size) :- 
  230.     $alloc_heap(Size,Sbuff),
  231.     $assert_alloc_t1(Palist,Sbuff).
  232.  
  233. $assert_alloc_t1([],_).
  234. $assert_alloc_t1([F|R],Supbuff) :- 
  235.     $assert_alloc_t1(F,Supbuff),$assert_alloc_t1(R,Supbuff).
  236. $assert_alloc_t1(P/A,Supbuff) :-
  237.     $bldstr(P,A,Term),
  238.     $assert_new_t_prref(Term,Prref,Supbuff).
  239.  
  240.  
  241.  
  242. $assert_call_s(Goal) :- 
  243.     $assert_get_prref(Goal,Prref,_,_),$db_call_prref_s(Goal,Prref).
  244.  
  245.  
  246. /* $assert_get_prref(Fact,Prref,Where,Supbuff):  where Fact is a
  247. literal, which should be dynamic. The e.p. field of the main functor
  248. symbol of Fact points to either a permanent prref, or a execv buffer
  249. that points to a temporary prref. If it is a permanent prref, Where
  250. is returned as 0; if a temporary, Where is set to 2, and Supbuff is
  251. bound to the superbuffer containing the clauses. */
  252.  
  253. $assert_get_prref(Fact,Prref) :- $assert_get_prref(Fact,Prref,_,_).
  254. $assert_get_prref(Fact,Prref,Where,Supbuff) :-
  255.     $symtype(Fact,Type),
  256.     (Type =:= 1 ->    /*DYNA: must be dynamic */
  257.         $opcode( noop, NoopOp ),
  258.         $opcode( executev, ExecOp ),
  259.         $buff_code(Fact,     0,  7 /*gepb*/, Vbuff),
  260.          ($buff_code(Vbuff,  4,  6 /*gs  */, NoopOp /*noop*/ ),
  261.           $buff_code(Vbuff,  6,  6, 0),
  262.           $buff_code(Vbuff,  8,  6, ExecOp /* executev */ ),
  263.           Where=2,
  264.           $buff_code(Vbuff, 12, 18 /*ubv*/ ,Prref),
  265.           $buff_code(Vbuff, 16, 18 /*ubv*/ ,Supbuff),
  266.           !
  267.          ;
  268.           Prref=Vbuff,Where=0
  269.          )
  270.         ;
  271.          Type =\= 0, /* if undefined, just fail */
  272.          $writename('Error, Illegal Predicate ref: '),
  273.          $write(Fact),$nl,fail
  274.     ).
  275.  
  276. /* $assert_put_prref(Fact,Prref):  where Fact is a literal and Prref
  277. is an prref.  Prref must  be bound  to an  existing prref.   The e.p.
  278. field of the psc entry for the main functor symbol of Fact  is set to
  279. point to the Prref.  */ 
  280.  
  281. $assert_put_prref(Fact,Prref) :-
  282.     $buff_code(Fact, 0, 9 /*pep*/ ,Prref).
  283.  
  284. /* $assert_abolish_i(Fact): initializes the predicate that is the main 
  285. functor symbol of Fact to be empty, by allocating a new empty Prref and 
  286. assigning it. */
  287.  
  288. $assert_abolish_i(Fact) :- 
  289.     $db_new_prref(Prref),$assert_put_prref(Fact,Prref).
  290.